Megarom/Megarom Macintosh CD Software (Quantum Leap)(1992).iso/COMPRESS/DeHQX-200/Source/MyUtilities.unit

Text File | 1991-08-23 | 9.3 KB | 382 lines | [TEXT/PJMM]

unit MyUtilities;
{ DeHQX v2.0.0 © Peter Lewis, Aug 1991 }

interface

    uses
        GestaltEqu, Traps, MyTypes;

    const
        about_dialog_ID = 128;
        help_dialog_ID = 129;

    var
        sysenv: sysEnvRec; { * - Setup by InitUtilities }
        system7: boolean;
        has_waitNextEvent: boolean; { * }
        has_appleEvents: boolean; { * }
        has_gestalt: boolean; { * }
        has_findfolder: boolean; { * }
        has_newStdFile: boolean; { * }
        has_HelpMgr: boolean; { * }
        in_foreground: boolean; { * }
        about_dialog, help_dialog: dialogPtr;

    type
        versionRecord = packed record
                version: integer;
                devcode: byte;
                revision: byte;
                country: integer;
                short: str15;
                long: str255;
            end;

    procedure InitUtilities;
    function Gestalt (selector: OSType; var response: LONGINT): OSErr;
    function TrapAvailable (tNumber: INTEGER): BOOLEAN; { * }
    function WaitGetNextEvent (em: integer; var er: eventRecord; sleep: longInt; rgn: rgnHandle): boolean; { * }
    function MyNumToString (n: longInt): str255;
    function CheckCancel: boolean;
    procedure DotDotDot (var s: str255; var width: integer);
    procedure SetItemEnable (mh: menuHandle; item: integer; enable: boolean);
    procedure DotItem (mh: menuHandle; item: integer; dotted: boolean);
    procedure DoHelp;
    procedure DoAbout;
    function SimpleClose (wp: windowPtr): boolean;
        { return true if you have to do something }
    function MyFrontWindow: boolean;
    function DAFrontWindow: boolean;
    function GetIndStrSize (size, id, index: integer): str255;
    procedure GetVersion (var vers: versionRecord);
    procedure SetVersionParamText (c2, c3: str255);
    function GetDirID (wdrn: integer; var vrn: integer; var dirID: longInt): OSErr;
    procedure SetItemText (dlg: dialogPtr; item: integer; text: str255);
    function GetVolInfo (var name: str63; var vrn: integer; index: integer; var CrDate: longInt): OSErr;
    procedure OutlineDefault1 (dp: dialogPtr; item: integer);
    procedure SetUpDefaultOutline (dp: dialogPtr; def_item, user_item: integer);
    procedure FlashItem (dlg: dialogPtr; item: integer);

implementation

    function TrapAvailable (tNumber: INTEGER): BOOLEAN;
{Check to see if a given trap is implemented. Babble as taken from IM6 }
        const
            TrapMask = $0800;
        var
            tType: TrapType;
            ignoreError: OSErr;
    begin
        if BAND(tNumber, TrapMask) > 0 then
            tType := ToolTrap
        else
            tType := OSTrap;
        if tType = ToolTrap then begin
            tNumber := BAND(tNumber, $7FF);
            if tNumber >= $400 then
                tNumber := _Unimplemented
            else if tNumber >= $200 then
                if NGetTrapAddress($A86E, ToolTrap) <> NGetTrapAddress($AA6E, ToolTrap) then
                    tNumber := _Unimplemented;
        end;
        TrapAvailable := NGetTrapAddress(tNumber, tType) <> GetTrapAddress(_Unimplemented);
    end; {TrapAvailable}

    function Gestalt (selector: OSType; var response: LONGINT): OSErr;
    begin
        if has_gestalt then
            Gestalt := XGestalt(selector, response)
        else
            Gestalt := gestaltUnknownErr;
    end;

    procedure InitUtilities;
        var
            oe: OSErr;
            gv: longInt;
    begin
        about_dialog := nil;
        help_dialog := nil;
        oe := SysEnvirons(kSysEnvironsVersion, sysEnv);
        system7 := sysenv.systemVersion >= $0700;
        has_gestalt := TrapAvailable(_Gestalt);
        has_waitNextEvent := TrapAvailable(_WaitNextEvent);
        in_foreground := true;
        oe := Gestalt(gestaltAppleEventsAttr, gv);
        has_appleEvents := (oe = noErr) and (gv = 1);
        oe := Gestalt(gestaltFindFolderAttr, gv);
        has_findfolder := (oe = noErr) and (BTST(gv, gestaltFindFolderPresent));
        oe := Gestalt(gestaltStandardFileAttr, gv);
        has_newStdFile := (oe = noErr) and (BTST(gv, gestaltStandardFile58));
        oe := Gestalt(gestaltHelpMgrAttr, gv);
        has_HelpMgr := (oe = noErr) and (BTST(gv, gestaltHelpMgrPresent));
    end;

    function WaitGetNextEvent (em: integer; var er: eventRecord; sleep: longInt; rgn: rgnHandle): boolean;
    begin
        if has_waitNextEvent then begin    {put us to sleep forever under MultiFinder}
            WaitGetNextEvent := WaitNextEvent(em, er, sleep, nil);
        end
        else begin
            SystemTask;                    {must be called if using GetNextEvent}
            WaitGetNextEvent := GetNextEvent(em, er);
        end;
    end;

    function MyNumToString (n: longInt): str255;
        var
            s: str255;
    begin
        if abs(n) < 4096 then
            NumToString(n, s)
        else if abs(n) < 4194304 then begin
            NumToString(n div 1024, s);
            s := Concat(s, 'k');
        end
        else begin
            NumToString(n div 1048576, s);
            s := Concat(s, 'M');
        end;
        MyNumToString := s;
    end;

    function CheckCancel: boolean;
        var
            er: eventRecord;
    begin
        if GetNextEvent(everyEvent, er) then
            with er do
                CheckCancel := (what = keyDown) and (BAND(message, charCodeMask) = ord('.')) and (BAND(modifiers, cmdKey) <> 0)
        else
            CheckCancel := false;
    end;

    procedure DotDotDot (var s: str255; var width: integer);
        var
            maxwidth, len: integer;
    begin
        maxwidth := width;
        width := StringWidth(s);
        if width > maxwidth then begin
            width := width + CharWidth('…');
{$PUSH}
{$R-}
            len := ord(s[0]);
            while (len > 0) and (width > maxwidth) do begin
                width := width - CharWidth(s[len]);
                len := len - 1;
            end;
            len := len + 1;
            s[0] := chr(len);
            s[len] := '…';
{$POP}
        end;
    end;

    procedure SetItemEnable (mh: menuHandle; item: integer; enable: boolean);
    begin
        if enable then
            EnableItem(mh, item)
        else
            DisableItem(mh, item);
    end;

    procedure DotItem (mh: menuHandle; item: integer; dotted: boolean);
    begin
        if dotted then
            SetItemMark(mh, item, '•')
        else
            SetItemMark(mh, item, chr(0));
    end;

    procedure DoAbout;
    begin
        if about_dialog <> nil then begin
            if FrontWindow <> about_dialog then
                SelectWindow(about_dialog);
        end
        else begin
            SetVersionParamText('', '');
            about_dialog := GetNewDialog(about_dialog_id, nil, POINTER(-1));
        end;
    end;

    procedure DoHelp;
        var
            a: integer;
    begin
        if help_dialog <> nil then begin
            if FrontWindow <> help_dialog then
                SelectWindow(help_dialog);
        end
        else begin
            SetVersionParamText('', '');
            help_dialog := GetNewDialog(help_dialog_id, nil, POINTER(-1));
        end;
    end;

    function SimpleClose (wp: windowPtr): boolean;
        { return true if you have to do something }
    begin
        if wp = about_dialog then begin
            DisposDialog(about_dialog);
            about_dialog := nil;
            SimpleClose := false;
        end
        else if wp = help_dialog then begin
            DisposDialog(help_dialog);
            help_dialog := nil;
            SimpleClose := false;
        end
        else
            SimpleClose := true;
    end;

    function MyFrontWindow: boolean;
        var
            wp: windowPtr;
    begin
        wp := FrontWindow;
        if wp = nil then
            MyFrontWindow := false
        else
            MyFrontWindow := windowPeek(wp)^.windowKind >= userKind;
    end;

    function DAFrontWindow: boolean;
        var
            wp: windowPtr;
    begin
        wp := FrontWindow;
        if wp = nil then
            DAFrontWindow := false
        else
            DAFrontWindow := windowPeek(wp)^.windowKind < 0;
    end;

    function GetIndStrSize (size, id, index: integer): str255;
        var
            s255: str255;
    begin
        GetIndString(s255, id, index);
        GetIndStrSize := copy(s255, 1, size - 1);
    end;

    procedure GetVersion (var vers: versionRecord);
        var
            vh: handle;
    begin
        with vers do begin
            vh := GetResource('vers', 1);
            if vh = nil then begin
                version := $0000;
                devcode := $20;
                revision := $00;
                country := 0;
                short := '0.0.0';
                long := 'Unknown v0.0.0';
            end
            else begin
                BlockMove(vh^, @vers, sizeof(vers));
{$PUSH}
 {$R-}
                BlockMove(Ptr(longint(vh^) + (longint(@short) - longint(@vers)) + ord(short[0]) + 1), @long, sizeof(long));
                if ord(short[0]) >= sizeof(short) then
                    short[0] := chr(sizeof(short) - 1);
{$POP}
                ReleaseResource(vh);
            end;
        end;
    end;

    procedure SetVersionParamText (c2, c3: str255);
        var
            vers: versionRecord;
    begin
        GetVersion(vers);
        ParamText(vers.short, vers.long, c2, c3);
    end;

    function GetDirID (wdrn: integer; var vrn: integer; var dirID: longInt): OSErr;
        var
            procID: longInt;
            oe: OSErr;
    begin
        oe := GetWDInfo(wdrn, vrn, dirID, procID);
        if oe <> noErr then begin
            vrn := wdrn;
            dirID := 0;
        end;
        GetDirID := oe;
    end;

    procedure SetItemText (dlg: dialogPtr; item: integer; text: str255);
        var
            it: integer;
            ih: handle;
            box: rect;
            oldtext: str255;
    begin
        GetDItem(dlg, item, it, ih, box);
        GetIText(ih, oldtext);
        if oldtext <> text then
            SetIText(ih, text);
    end;

    function GetVolInfo (var name: str63; var vrn: integer; index: integer; var CrDate: longInt): OSErr;
        var
            pb: paramBlockRec;
            oe: OSErr;
    begin
        with pb do begin
            pb.ioNamePtr := @name;
            ioVRefNum := vrn;
            ioVolIndex := index;
            oe := PBGetVInfo(@pb, false);
            if oe = noErr then begin
                vrn := ioVRefNum;
                CrDate := ioVCrDate;
            end;
        end;
        GetVolInfo := oe;
    end;

    procedure OutlineDefault1 (dp: dialogPtr; item: integer);
        var
            kind: integer;
            h: handle;
            r: rect;
    begin
        GetDItem(dp, 1, kind, h, r);
        PenSize(3, 3);
        InsetRect(r, -4, -4);
        FrameRoundRect(r, 16, 16);
    end;

    procedure SetUpDefaultOutline (dp: dialogPtr; def_item, user_item: integer);
        var
            kind: integer;
            h: handle;
            r: rect;
    begin
        if def_item <> 1 then
            DebugStr('MyUtilities:SetUpDefaultOutline:Cant handle anything except 1 yet');
        GetDItem(dp, user_item, kind, h, r);
        InsetRect(r, -10, -10);
        SetDItem(dp, user_item, userItem, handle(@OutlineDefault1), r);
    end;

    procedure FlashItem (dlg: dialogPtr; item: integer);
        var
            kind: integer;
            h: handle;
            r: rect;
            f: longInt;
    begin
        GetDItem(dlg, item, kind, h, r);
        HiliteControl(controlHandle(h), 1);
        Delay(2, f);
        HiliteControl(controlHandle(h), 0);
    end;

end.